Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue30/pathed3/PATHED3.ZIP/Source/SolutionsUnlimitedPathEd.pas

Pascal/Delphi Source File | 1997-12-28 | 20.2 KB | 770 lines

{-------------------------------------------------------------------------------
Name                    :    SolutionsUnlimitedPathEd.pas
Author                : Robert Kozak
Date                    : November 1, 1997

Copyright            : ⌐ 1997 Solutions Unlimited. All Rights Reserved.

Version             : 1.0
Last Updated    :

Description        : This is an expert for managing the Paths in Delphi.

Notes:
-------------------------------------------------------------------------------}
unit SolutionsUnlimitedPathEd;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, Registry, StdCtrls, ExptIntf, ToolIntf, Placemnt,
  ExtCtrls, rkCommon, Menus, checklst, SolutionsUnlimitedBrowseFolder, rkAboutForm;

const
  DELPHI_3_PATHHISTORY        = '\Software\Borland\Delphi\3.0\HistoryList\hiLibraryPath';
    DELPHI_3_PATH                             = '\Software\Borland\Delphi\3.0\Library\';
    DELPHI_3_FULLPATH                        = '\Software\Borland\Delphi\3.0\Library\FULLPath\';
    DELPHI_3_KNOWN_PACKAGES         = '\Software\Borland\Delphi\3.0\Known Packages';
    DELPHI_3_DISABLED_PACKAGES    = '\Software\Borland\Delphi\3.0\Disabled Packages';

  DELPHI_3_SOLUTIONS                    = '\Software\Borland\Delphi\3.0\Solutions\';
    DELPHI_3_PATH_KEY                        = 'SearchPath';

type
  TPathEdExpert = class(TIExpert)
  private
    fMenuItem: TIMenuItemIntf;
    procedure MenuClick(Sender: TIMenuItemIntf);
    procedure NewWndProc(var Msg : TMessage); virtual;
    protected
        procedure PreProcessMsg(Sender: TObject; var msg: TMessage; var bContinue: Boolean);
    procedure PostProcessMsg(Sender: TObject; var msg: TMessage; var bContinue: Boolean);
        procedure UpdateDelphiPath;
  public
        constructor Create;
    destructor Destroy; override;
    procedure Execute; override;
    function GetAuthor: string; override;
    function GetComment: string; override;
    function GetGlyph: HICON; override;
    function GetIDString: string; override;
    function GetMenuText: string; override;
    function GetName: string; override;
    function GetPage: string; override;
    function GetState: TExpertState; override;
    function GetStyle: TExpertStyle; override;
    property MenuItem: TIMenuItemIntf read fMenuItem;
  end;

  TfrmSetPath = class(TForm)
    Panel1: TPanel;
    btnDown: TButton;
    btnAdd: TButton;
    btnUp: TButton;
    btnRemove: TButton;
    StatusBar1: TStatusBar;
    FormStorage: TFormStorage;
    pnlList: TPanel;
    TabControl1: TTabControl;
    btnOptions: TButton;
    PopupMenu1: TPopupMenu;
    Sort1: TMenuItem;
    btnClose: TButton;
    lstPath: TCheckListBox;
    N1: TMenuItem;
    About1: TMenuItem;
    procedure btnAddClick(Sender: TObject);
    procedure btnRemoveClick(Sender: TObject);
    procedure btnUpClick(Sender: TObject);
    procedure btnDownClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormCreate(Sender: TObject);
    procedure FormStorageRestorePlacement(Sender: TObject);
    procedure btnOptionsClick(Sender: TObject);
    procedure Sort1Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
  private
    { Private declarations }
    FDisplayHistory : Boolean;
    FDisplayPackagePath: Boolean;
    FDisplayProject : Boolean;
    FSyncPackages : Boolean;
        OldList : TStringList;
    PackagePath : TStringList;
    procedure SaveList;
    procedure RestoreList;
    function ListSaved : Boolean;
    procedure ParsePath;
      procedure WritePath;
      procedure ReadPath;
    procedure SyncWithPackages;
    procedure AddSubDirs(Sender: TObject);
  protected
    procedure SetDisplayPackagePath(Value : Boolean);
    procedure SetSyncPackages(Value : Boolean);
  public
    { Public declarations }
    property DisplayPackagePath: Boolean read FDisplayPackagePath write SetDisplayPackagePath;
    property SyncPackages : Boolean read FSyncPackages write SetSyncPackages;
  end;

    procedure Register;

var
  frmSetPath: TfrmSetPath;
    WindowHook : HHook;
  DoSubClass : Boolean;
    PathEdExpert : TPathEdExpert;
  Path : string;

implementation

uses
  SolutionsUnlimitedPathOptions;

resourcestring
  sName = 'Library Search Path Expert';
  sMenuText = 'Edit Library Search &Path...';
  sMenuName = 'EditLibrarySearchPathItem';

{$R *.DFM}

var
  NewWndProcPointer : TFarProc;
  OrgWndProcPointer : LongInt;
  WindowHandle : HWnd;

procedure TPathEdExpert.NewWndProc(var Msg : TMessage);
//function NewWndProc(Handle : HWND; Msg : UInt; wparam : WPARAM; lparam: LPARAM): LRESULT; stdcall;
var
    EnvDialog : TCustomForm;
  LibraryTab :  TTabSheet;

  PathCombo : TComboBox;
  temp : string;

begin
  case Msg.Msg of
    WM_WINDOWPOSCHANGING :
    begin
        TWindowPos(pWindowPos(Msg.Lparam)^).cx := 0;
        TWindowPos(pWindowPos(Msg.Lparam)^).cy := 0;
      Msg.Result := 0;
    end;

        CM_ACTIVATE:
          if Application.FindComponent('EnvDialog') <> nil then
        begin
            EnvDialog := TForm(Application.FindComponent('EnvDialog'));
          EnvDialog.ModalResult := mrOK;
           PathCombo := TComboBox(EnvDialog.FindComponent('LibOptionsDlg2').FindComponent('ecLibraryPath'));
        PathCombo.Text := Path;
          PostMessage(EnvDialog.Handle, CM_DEACTIVATE, 0, 0);
        Msg.Result := 0;
        end;
        CM_DEACTIVATE:
          if Application.FindComponent('EnvDialog') <> nil then
        begin
          EnvDialog := TForm(Application.FindComponent('EnvDialog'));
          EnvDialog.ModalResult := mrOK;
        Msg.Result := 0;
        end;

//  else Result := CallWindowProc(Pointer(OrgWndProcPointer), Handle, Msg, wparam, lparam);
  else Dispatch(Msg);
  end;
end;

{------------------------------------------------------------------------------}

function Hook(Code : Integer; wparam :WPARAM; lParam : LPARAM): LResult; stdcall;
var
    aClassName : array [0..25] of char;
  i: integer;

begin
    with TCWPStruct(PCWPStruct(lparam)^) do
      if (Message = WM_ParentNotify) and (LoWord(wparam) = WM_CREATE) then
        begin
             WindowHandle := GetParent(lParam);
      GetClassName(WindowHandle, aClassName, 25);

      if (aClassName = 'TEnvDialog') and (DoSubClass) then
      begin
        FlashWindow(Application.MainForm.Handle, False);
        NewWndProcPointer := MakeObjectInstance(PathEdExpert.NewWndProc);
            OrgWndProcPointer := LongInt(SetWindowLong(WindowHandle, gwl_WndProc, LongInt(NewWndProcPointer)));
      end;
      end;

    Result := CallNextHookEx(WindowHook, Code, WParam, Lparam);
end;

{ TPathEdExpert ---------------------------------------------------------------}

constructor TPathEdExpert.Create;
var
    Index : integer;

begin
  inherited Create;

  with ToolServices.GetMainMenu.FindMenuItem('InstallPackagesItem') do
  begin
      Index := GetIndex + 1;
        fMenuItem := GetParent.InsertItem(Index,sMenuText,sMenuName,'',0,0,0,[mfEnabled,mfVisible],MenuClick);
  end;

  WindowHook := SetWindowsHookEx(WH_CALLWNDPROC, @Hook, HInstance, GetCurrentThreadID);
end;

{------------------------------------------------------------------------------}

destructor TPathEdExpert.Destroy;
begin
  MenuItem.Free;

  SetWindowLong(WindowHandle, gwl_WndProc, OrgWndProcPointer);

    UnHookWindowsHookEx(WindowHook);
  inherited Destroy;
end;

{------------------------------------------------------------------------------}

procedure TPathEdExpert.MenuClick(Sender:
   TIMenuItemIntf);
begin
  Execute;
end;
{------------------------------------------------------------------------------}

function TPathEdExpert.GetStyle: TExpertStyle;
begin
  Result := esAddIn;
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetName: string;
begin
  Result := sName;
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetIDString: string;
begin
  Result := 'Solutions Unlimited.PathEditor';
end;

{------------------------------------------------------------------------------}

procedure TPathEdExpert.Execute;
begin
    with TfrmSetPath.Create(nil) do
  try
        ShowModal;
  finally
    Free;
  end;

  UpdateDelphiPath;
end;

{------------------------------------------------------------------------------}

procedure TPathEdExpert.PreProcessMsg(Sender: TObject;
  var msg: TMessage; var bContinue: Boolean);
begin     case msg.msg of
    WM_WINDOWPOSCHANGING :
    begin
        TWindowPos(pWindowPos(Msg.Lparam)^).cx := 0;
        TWindowPos(pWindowPos(Msg.Lparam)^).cy := 0;
    end;
  end;
end;
{------------------------------------------------------------------------------}
procedure TPathEdExpert.PostProcessMsg(Sender: TObject;
  var msg: TMessage; var bContinue: Boolean);var
    EnvDialog : TCustomForm;
  LibraryTab :  TTabSheet;

  PathCombo : TComboBox;
  temp : string;

begin
  // Hard coding the Component Names for this release. Will create a wrapper Class
  // for Delphi in the next release.
    case Msg.Msg of
        CM_ACTIVATE:
          if Application.FindComponent('EnvDialog') <> nil then
        begin
            EnvDialog := TForm(Application.FindComponent('EnvDialog'));
          EnvDialog.ModalResult := mrOK;
          PathCombo := TComboBox(EnvDialog.FindComponent('LibOptionsDlg2').FindComponent('ecLibraryPath'));
        PathCombo.Text := Path;
          PostMessage(EnvDialog.Handle, CM_DEACTIVATE, 0, 0);
        end;
        CM_DEACTIVATE:
          if Application.FindComponent('EnvDialog') <> nil then
        begin
          EnvDialog := TForm(Application.FindComponent('EnvDialog'));
          EnvDialog.ModalResult := mrOK;
        end;
    end;
end;

procedure TPathEdExpert.UpdateDelphiPath;
var
    ABuilder : TForm;
  EnvDialogItem : TMenuItem;

begin
    DoSubClass := True;
  if Assigned(Application.FindComponent('AppBuilder')) then
  begin
      ABuilder := TForm(Application.FindComponent('AppBuilder'));
    if Assigned(ABuilder.FindComponent('ToolsOptionsItem')) then
    begin
          EnvDialogItem := TMenuItem(ABuilder.FindComponent('ToolsOptionsItem'));
            EnvDialogItem.Click;
        DoSubClass := False;
      end;
    end;
end;

// These methods are not important for an AddIn expert;
{------------------------------------------------------------------------------}

function TPathEdExpert.GetAuthor: string;
begin
    Result := ''
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetComment: string;
begin
    Result := ''
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetGlyph: HICON;
begin
    Result := 0
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetMenuText: string;
begin
    Result := '';
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetPage: string;
begin
    Result := ''
end;

{------------------------------------------------------------------------------}

function TPathEdExpert.GetState: TExpertState;
begin
    Result := []
end;

{ TfrmSetPath -----------------------------------------------------------------}procedure TfrmSetPath.SaveList;
var
 i : Integer;

begin
    OldList.Clear;
    for i := 0 to lstPath.Items.Count-1 do
      OldList.AddObject(lstPath.Items[i],Pointer(Ord(lstPath.State[i])));
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.RestoreList;
var
 i : Integer;

begin
    lstPath.Clear;
    for i := 0 to OldList.Count-1 do
  begin
      lstPath.Items.Add(OldList[i]);
    lstPath.State[i] := TCheckBoxState(OldList.Objects[i]);
  end;
end;

{------------------------------------------------------------------------------}

function TfrmSetPath.ListSaved : Boolean;
begin
    Result := OldList.Count > 0;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.ParsePath;
var
    s, x : string;

begin
    s := '';
  x := '';

  with TRegistry.Create do
  try
      RootKey := HKEY_CURRENT_USER;
    OpenKey(DELPHI_3_PATH, False);
        s := ReadString(DELPHI_3_PATH_KEY);

    while s <> '' do
    begin
      lstPath.Items.Add(strToken(s,';'));
      lstPath.State[lstPath.Items.Count-1] := cbChecked
    end;
  finally
      Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.WritePath;
var
  i : Integer;
  b : string;

begin
    Path := '';

    for i := 0 to lstPath.Items.Count-1 do
        if lstPath.State[i] = cbChecked then Path := Path + lstPath.Items[i] + ';';

    Path := Copy(Path,1,Length(Path)-1);

  with TRegistry.Create do
  try
      RootKey := HKEY_CURRENT_USER;
    if not OpenKey(DELPHI_3_PATH,False) then Exit;
    if not ValueExists(DELPHI_3_PATH_KEY) then Exit;

       WriteString(DELPHI_3_PATH_KEY, Path);

    // Clear out the values. Then Add them in.
       DeleteKey(DELPHI_3_FULLPATH);
       OpenKey(DELPHI_3_FULLPATH, True);
        for i := 0 to lstPath.Items.Count-1 do
    begin
        if lstPath.State[i] = cbChecked
      then b := 'T'
      else b := 'F';

        WriteString(IntToStr(i),lstPath.Items[i]+','+b);
    end;
  finally
      Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.ReadPath;
var
    s : string;
  b: Boolean;
    i : Integer;
  KeyInfo : TRegKeyInfo;

begin
    lstPath.Clear;

  with TRegistry.Create do
  try
      RootKey := HKEY_CURRENT_USER;
    if not OpenKey(DELPHI_3_FULLPATH,False) then
    begin
        ParsePath;
        Exit;
        end;

        GetKeyInfo(KeyInfo);

        for i := 0 to KeyInfo.NumValues-1 do
    begin
        s := ReadString(IntToStr(i));
        b := (Copy(s,Pos(',',s)+1,1) = 'T');
        s := Copy(s,1,Pos(',',s)-1);
        lstPath.Items.Add(s);
            if b then lstPath.State[i] := cbChecked;
    end;
  finally
      Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.SyncWithPackages;
var
  i : Integer;
    s : string;

begin
     SaveList;

  PackagePath.Clear;
    with TRegistry.Create do
  try

      RootKey := HKEY_CURRENT_USER;
    if not OpenKey(DELPHI_3_KNOWN_PACKAGES,False) then Exit;

    GetValueNames(PackagePath);

    if DisplayPackagePath then
          for i := 0 to PackagePath.Count-1 do
        with PackagePath do
        begin
            s := ExtractFilePath(PackagePath[i]);
          s := Copy(s,1,Length(s)-1);
              if lstPath.Items.IndexOf(s) = -1 then
          begin
              Add(s);
            lstPath.Items.Add(s);
                      lstPath.State[lstPath.Items.Count-1] := cbChecked;
          end;
        end;
  finally
      Free;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.AddSubDirs(Sender: TObject);
begin
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.SetDisplayPackagePath(Value : Boolean);
begin
  if FDisplayPackagePath <> Value then
  begin
    FDisplayPackagePath := Value;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.SetSyncPackages(Value : Boolean);
begin
  if FSyncPackages <> Value then
  begin
    FSyncPackages := Value;

    if FSyncPackages
    then SyncWithPackages
    else
      if ListSaved then RestoreList;
  end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnAddClick(Sender: TObject);
var
    s : string;
  sl : TStringList;
  i : Integer;

begin
  with TBrowseFolder.Create(nil) do
  try
    Title := 'Add Directory to Library Search Path';
    ShowPathInStatusArea := True;
    CustomButtonVisible := True;
    CustomButtonCaption := 'Add Sub Directories';
    CustomButtonType := btCheckBox;
    CustomButtonWidth := 150;
      if Execute then
          with lstPath do
      begin
        if ItemIndex < 0 then ItemIndex := 0;
        // Adding SubDirs?
        if CustomButtonChecked then
        begin
          sl := TStringList.Create;
          sl.Clear;
          try
            ReadDirectoryNames(Directory+'\', sl);
            for i := sl.Count-1 downto 0 do
            begin
              s := Directory+'\'+sl[i];
                if Items.IndexOf(s) = -1 then Items.Insert(ItemIndex,s);
              State[Items.IndexOf(s)] := cbChecked;
              ItemIndex := Items.IndexOf(s);
            end;
          finally
            sl.Free;
          end;
        end;

        s := Directory;
          if Items.IndexOf(s) = -1 then Items.Insert(ItemIndex,s);
        State[Items.IndexOf(s)] := cbChecked;
        ItemIndex := Items.IndexOf(s);
      end;
  finally
    SetFocus;
    Free;
  end;

  StatusBar1.SimpleText := 'Path has been updated.';
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnRemoveClick(Sender: TObject);
var
  OldIndex : Integer;

begin
    with lstPath do
  begin
    OldIndex := ItemIndex;
        if ItemIndex > -1 then Items.Delete(ItemIndex);

    Dec(OldIndex);
    if OldIndex < 0 then OldIndex := 0;
    ItemIndex := OldIndex;
  end;

  StatusBar1.SimpleText := 'Path has been updated.';
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnUpClick(Sender: TObject);
var
    s : string;

begin
    with lstPath do
        if ItemIndex > 0 then
    begin
        s := Items[ItemIndex];
        Items.Exchange(ItemIndex, ItemIndex-1);
      ItemIndex := Items.IndexOf(s);
      SetFocus;
    end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.btnDownClick(Sender: TObject);
var
    s : string;

begin
    with lstPath do
        if ItemIndex < Items.Count-1 then
    begin
        s := Items[ItemIndex];
        Items.Exchange(ItemIndex, ItemIndex+1);
      ItemIndex := Items.IndexOf(s);
      SetFocus;
    end;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.FormClose(Sender: TObject; var Action: TCloseAction);
begin
    WritePath;
    OldList.Free;
  PackagePath.Free;
end;

{------------------------------------------------------------------------------}

procedure TfrmSetPath.FormCreate(Sender: TObject);
begin
    OldList := TStringList.Create;
  OldList.Clear;
    ReadPath;

  PackagePath := TStringList.Create;
end;

{------------------------------------------------------------------------------}
procedure TfrmSetPath.FormStorageRestorePlacement(Sender: TObject);begin
  with TRegistry.Create do
  try
      RootKey := HKEY_CURRENT_USER;
    if not OpenKey(FormStorage.IniFileName+'\'+FormStorage.IniSection,False) then
    begin
        Exit;
        end;

    if ValueExists('cbxDisplayPackages_Checked') then
      FDisplayPackagePath := (ReadString('cbxDisplayPackages_Checked') = 'True');

    if ValueExists('cbxSync_Checked') then
          SyncPackages := (ReadString('cbxSync_Checked') = 'True');
  finally
    Free;
  end;
end;

{------------------------------------------------------------------------------}
procedure Register;begin
    PathEdExpert := TPathEdExpert.Create;
  RegisterLibraryExpert(PathEdExpert);
end;
{------------------------------------------------------------------------------}
procedure TfrmSetPath.btnOptionsClick(Sender: TObject);begin
  with TfrmPathOptions.Create(nil) do
  try
    if ShowModal = mrOK then
    begin
      DisplayPackagePath  := cbxDisplayPackages.Checked;
      SyncPackages        := cbxSync.Checked;
    end;
  finally
    Free;
  end;
end;

{------------------------------------------------------------------------------}
procedure TfrmSetPath.Sort1Click(Sender: TObject);begin
  lstPath.Sorted := True;
end;

procedure TfrmSetPath.About1Click(Sender: TObject);
begin
  with TfrmrkAbout.Create(nil) do
  try
    Copyright := '⌐ Copyright 1997 Robert N. Kozak. All Rights Reserved.';
    Version := 'Version 3.02';
    AppName := 'Delphi Library Search Path Editor';
    Title := 'About Delphi Library Search Path Editor';
    SecretMessage := 'You found the Secret Message!';
    ShowModal;
  finally
    Free;
  end;
end;

end.